
-----------------------------------------------------------------------------
--  zGroup.hs : code generation for strongly typed integer groups
--
--  Template haskell functions to generate integer group types
-----------------------------------------------------------------------------

module Group.Z (

	zGrpA, mkGroup, generate

	) where

import Group

import Language.Haskell.TH
import Language.Haskell.TH.Syntax(runQ)
import Language.Haskell.TH.Lib(plainTV)

-----------------------------------------------------------------------------
-- user facing code to generate groups
mkGroup :: Number -> Order -> OpType -> DecsQ
mkGroup Integer (Order a) Additive = zGrpA a

-----------------------------------------------------------------------------
-- template haskell top level function for group generation
zGrpA :: Integer -> DecsQ
zGrpA n = do {
             gmd <- zgrpmD n;
             gd <- zgrpD n;
             gdi <- zgrpI n;
             gsi <- zgrpmShowI n;
             return $ gmd ++ gd ++ gdi ++ gsi;
           }

-----------------------------------------------------------------------------
-- generate the name of the group datatype based on an integer
zgName ::Integer -> String
zgName n = "Z" ++ (show n)

-----------------------------------------------------------------------------
-- generate the name of the group member datatype based on an integer
zgmName :: Integer -> String
zgmName n = "Z" ++ (show n) ++ "M"

-----------------------------------------------------------------------------
-- generate AST for the group datatype based on an integer
zgrpD ::Integer -> DecsQ
zgrpD n = (dataD (cxt []) 
         (mkName $ zgName n ) 
         ([]) 
         ([normalC (mkName $ zgName n) []]) 
         ([])
        ) >>= (\x ->return [x])

-----------------------------------------------------------------------------
-- generate AST for the group member datatype based on an integer
zgrpmD ::Integer ->DecsQ
zgrpmD n = (dataD (cxt [])
         (mkName $ zgmName n)
         ([plainTV $ mkName "a"])
         ([normalC (mkName $ zgmName n) 
           [(strictType (return NotStrict) (conT $ mkName "Integer"))]
         ])
         ([])
        ) >>= (\x ->return [x])
            
-----------------------------------------------------------------------------
-- generate the AST for the Show implementation of the group member
zgrpmShowI ::Integer ->DecsQ
zgrpmShowI n = 
  (instanceD (cxt [])
   (appT (conT $ mkName "Show")
         (appT (conT $ mkName $ zgmName n)
               (varT $ mkName "a")))
   ([
     (funD (mkName "show")
           [(clause [(conP (mkName $ zgmName n) [varP $ mkName "a"])]
                    (normalB $ appE (varE $ mkName "show")
                                    (varE $ mkName "a")) [] )])
     ])
  ) >>= (\x ->return [x])

-----------------------------------------------------------------------------
-- generate AST for the group datatype Group instance implementation
zgrpI ::Integer ->DecsQ
zgrpI n = 
  (instanceD (cxt [])
    (appT (appT (appT (conT $ mkName "Group") 
                      (conT gn)) -- group name
                (conT gmn)) -- group member name
          (conT $ mkName "Integer"))
    ([ 
      (funD (mkName "lift") 
           [(clause [(conP gn []), (varP $ mkName "a")]
                    (normalB $ appE (conE gmn)
                                    (infixE (Just (varE $ mkName "a"))
                                            (varE $ mkName "mod")
                                            (Just (litE $ integerL n)) 
                                    ))[])]),
             
     (funD (mkName "suc")
      [(clause [(conP gmn [varP $ mkName "a"])]
               (normalB $ (appE (appE (varE $ mkName "lift")
                                      (conE gn)) 
                                (infixE (Just (varE $ mkName "a"))
                                        (varE $ mkName "+")
                                        (Just (litE $ integerL 1))
                                ))) [])]),

     (funD (mkName "order") 
      [(clause [(conP gn [])]
               (normalB $ (appE (conE $ mkName "Order")
                                (litE $ integerL n)
                          )) [])]),
     (funD (mkName "u")
      [(clause [(conP gn [])]
               (normalB $ (appE (appE (varE $ mkName "lift")
                                      (conE gn ))
                                (litE $ integerL 0)
                          )) [] )]),
     (funD (mkName "gen")
      [(clause [(conP gn [])]
               (normalB $ (appE (appE (appE (varE $ mkName "generate")
                                            (litE $ integerL n))
                                      (appE (varE $ mkName "u")
                                            (conE $ gn)))
                               (varE $ mkName "suc"))) [] )]),
     (funD (mkName "op")
      [(clause [(conP gmn [varP $ mkName "a"]), (conP gmn [varP $ mkName "b"])]
               (normalB $ (appE (appE (varE $ mkName "lift")
                                      (conE gn))
                                (infixE (Just $ varE $ mkName "a")
                                        (varE $ mkName "+")
                                        (Just $ varE $ mkName "b")))) [])])
     
   ])

   
  ) >>= (\x ->return [x]) where
           gn = mkName $ zgName n
           gmn = mkName $ zgmName n

-----------------------------------------------------------------------------
-- generate AST for the group datatype based on an integer
generate :: Integer -> e -> (e -> e) -> [e]
--          ^order    ^elem  ^next elem  ^result
generate 0 _ _ = []
generate i e f = e : generate (i-1) (f e) f

